home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / gnu / calc202a.lha / calc-2.02a / calc-fin.el < prev    next >
Lisp/Scheme  |  1993-06-01  |  13KB  |  453 lines
  1. ;; Calculator for GNU Emacs, part II [calc-fin.el]
  2. ;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
  3. ;; Written by Dave Gillespie, daveg@synaptics.com.
  4.  
  5. ;; This file is part of GNU Emacs.
  6.  
  7. ;; GNU Emacs is distributed in the hope that it will be useful,
  8. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  9. ;; accepts responsibility to anyone for the consequences of using it
  10. ;; or for whether it serves any particular purpose or works at all,
  11. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  12. ;; License for full details.
  13.  
  14. ;; Everyone is granted permission to copy, modify and redistribute
  15. ;; GNU Emacs, but only under the conditions described in the
  16. ;; GNU Emacs General Public License.   A copy of this license is
  17. ;; supposed to have been given to you along with GNU Emacs so you
  18. ;; can know your rights and responsibilities.  It should be in a
  19. ;; file named COPYING.  Among other things, the copyright notice
  20. ;; and this notice must be preserved on all copies.
  21.  
  22.  
  23.  
  24. ;; This file is autoloaded from calc-ext.el.
  25. (require 'calc-ext)
  26.  
  27. (require 'calc-macs)
  28.  
  29. (defun calc-Need-calc-fin () nil)
  30.  
  31.  
  32. ;;; Financial functions.
  33.  
  34. (defun calc-fin-pv ()
  35.   (interactive)
  36.   (calc-slow-wrapper
  37.    (if (calc-is-hyperbolic)
  38.        (calc-enter-result 3 "pvl" (cons 'calcFunc-pvl (calc-top-list-n 3)))
  39.      (if (calc-is-inverse)
  40.      (calc-enter-result 3 "pvb" (cons 'calcFunc-pvb (calc-top-list-n 3)))
  41.        (calc-enter-result 3 "pv" (cons 'calcFunc-pv (calc-top-list-n 3))))))
  42. )
  43.  
  44. (defun calc-fin-npv (arg)
  45.   (interactive "p")
  46.   (calc-slow-wrapper
  47.    (if (calc-is-inverse)
  48.        (calc-vector-op "npvb" 'calcFunc-npvb (1+ arg))
  49.      (calc-vector-op "npv" 'calcFunc-npv (1+ arg))))
  50. )
  51.  
  52. (defun calc-fin-fv ()
  53.   (interactive)
  54.   (calc-slow-wrapper
  55.    (if (calc-is-hyperbolic)
  56.        (calc-enter-result 3 "fvl" (cons 'calcFunc-fvl (calc-top-list-n 3)))
  57.      (if (calc-is-inverse)
  58.      (calc-enter-result 3 "fvb" (cons 'calcFunc-fvb (calc-top-list-n 3)))
  59.        (calc-enter-result 3 "fv" (cons 'calcFunc-fv (calc-top-list-n 3))))))
  60. )
  61.  
  62. (defun calc-fin-pmt ()
  63.   (interactive)
  64.   (calc-slow-wrapper
  65.    (if (calc-is-hyperbolic)
  66.        (calc-enter-result 3 "fvl" (cons 'calcFunc-fvl (calc-top-list-n 3)))
  67.      (if (calc-is-inverse)
  68.      (calc-enter-result 3 "pmtb" (cons 'calcFunc-pmtb (calc-top-list-n 3)))
  69.        (calc-enter-result 3 "pmt" (cons 'calcFunc-pmt (calc-top-list-n 3))))))
  70. )
  71.  
  72. (defun calc-fin-nper ()
  73.   (interactive)
  74.   (calc-slow-wrapper
  75.    (if (calc-is-hyperbolic)
  76.        (calc-enter-result 3 "nprl" (cons 'calcFunc-nperl (calc-top-list-n 3)))
  77.      (if (calc-is-inverse)
  78.      (calc-enter-result 3 "nprb" (cons 'calcFunc-nperb
  79.                        (calc-top-list-n 3)))
  80.        (calc-enter-result 3 "nper" (cons 'calcFunc-nper
  81.                      (calc-top-list-n 3))))))
  82. )
  83.  
  84. (defun calc-fin-rate ()
  85.   (interactive)
  86.   (calc-slow-wrapper
  87.    (calc-pop-push-record 3
  88.              (if (calc-is-hyperbolic) "ratl"
  89.                (if (calc-is-inverse) "ratb" "rate"))
  90.              (calc-to-percentage
  91.               (calc-normalize
  92.                (cons (if (calc-is-hyperbolic) 'calcFunc-ratel
  93.                    (if (calc-is-hyperbolic) 'calcFunc-rateb
  94.                      'calcFunc-rate))
  95.                  (calc-top-list-n 3))))))
  96. )
  97.  
  98. (defun calc-fin-irr (arg)
  99.   (interactive "P")
  100.   (calc-slow-wrapper
  101.    (if (calc-is-inverse)
  102.        (calc-vector-op "irrb" 'calcFunc-irrb arg)
  103.      (calc-vector-op "irr" 'calcFunc-irr arg)))
  104. )
  105.  
  106. (defun calc-fin-sln ()
  107.   (interactive)
  108.   (calc-slow-wrapper
  109.    (calc-enter-result 3 "sln" (cons 'calcFunc-sln (calc-top-list-n 3))))
  110. )
  111.  
  112. (defun calc-fin-syd ()
  113.   (interactive)
  114.   (calc-slow-wrapper
  115.    (calc-enter-result 4 "syd" (cons 'calcFunc-syd (calc-top-list-n 4))))
  116. )
  117.  
  118. (defun calc-fin-ddb ()
  119.   (interactive)
  120.   (calc-slow-wrapper
  121.    (calc-enter-result 4 "ddb" (cons 'calcFunc-ddb (calc-top-list-n 4))))
  122. )
  123.  
  124.  
  125. (defun calc-to-percentage (x)
  126.   (cond ((Math-objectp x)
  127.      (setq x (math-mul x 100))
  128.      (if (Math-num-integerp x)
  129.          (setq x (math-trunc x)))
  130.      (list 'calcFunc-percent x))
  131.     ((Math-vectorp x)
  132.      (cons 'vec (mapcar 'calc-to-percentage (cdr x))))
  133.     (t x))
  134. )
  135.  
  136. (defun calc-convert-percent ()
  137.   (interactive)
  138.   (calc-slow-wrapper
  139.    (calc-pop-push-record 1 "c%" (calc-to-percentage (calc-top-n 1))))
  140. )
  141.  
  142. (defun calc-percent-change ()
  143.   (interactive)
  144.   (calc-slow-wrapper
  145.    (let ((res (calc-normalize (cons 'calcFunc-relch (calc-top-list 2)))))
  146.      (calc-pop-push-record 2 "%ch" (calc-to-percentage res))))
  147. )
  148.  
  149.  
  150.  
  151.  
  152.  
  153. ;;; Financial functions.
  154.  
  155. (defun calcFunc-pv (rate num amount &optional lump)
  156.   (math-check-financial rate num)
  157.   (math-with-extra-prec 2
  158.     (let ((p (math-pow (math-add 1 rate) num)))
  159.       (math-add (math-mul amount
  160.               (math-div (math-sub 1 (math-div 1 p))
  161.                     rate))
  162.         (math-div (or lump 0) p))))
  163. )
  164. (put 'calcFunc-pv 'math-expandable t)
  165.  
  166. (defun calcFunc-pvl (rate num amount)
  167.   (calcFunc-pv rate num 0 amount)
  168. )
  169. (put 'calcFunc-pvl 'math-expandable t)
  170.  
  171. (defun calcFunc-pvb (rate num amount &optional lump)
  172.   (math-check-financial rate num)
  173.   (math-with-extra-prec 2
  174.     (let* ((p (math-pow (math-add 1 rate) num)))
  175.       (math-add (math-mul amount
  176.               (math-div (math-mul (math-sub 1 (math-div 1 p))
  177.                           (math-add 1 rate))
  178.                     rate))
  179.         (math-div (or lump 0) p))))
  180. )
  181. (put 'calcFunc-pvb 'math-expandable t)
  182.  
  183. (defun calcFunc-npv (rate &rest flows)
  184.   (math-check-financial rate 1)
  185.   (math-with-extra-prec 2
  186.     (let* ((flat (math-flatten-many-vecs flows))
  187.        (pp (math-add 1 rate))
  188.        (p pp)
  189.        (accum 0))
  190.       (while (setq flat (cdr flat))
  191.     (setq accum (math-add accum (math-div (car flat) p))
  192.           p (math-mul p pp)))
  193.       accum))
  194. )
  195. (put 'calcFunc-npv 'math-expandable t)
  196.  
  197. (defun calcFunc-npvb (rate &rest flows)
  198.   (math-check-financial rate 1)
  199.   (math-with-extra-prec 2
  200.     (let* ((flat (math-flatten-many-vecs flows))
  201.        (pp (math-add 1 rate))
  202.        (p 1)
  203.        (accum 0))
  204.       (while (setq flat (cdr flat))
  205.     (setq accum (math-add accum (math-div (car flat) p))
  206.           p (math-mul p pp)))
  207.       accum))
  208. )
  209. (put 'calcFunc-npvb 'math-expandable t)
  210.  
  211. (defun calcFunc-fv (rate num amount &optional initial)
  212.   (math-check-financial rate num)
  213.   (math-with-extra-prec 2
  214.     (let ((p (math-pow (math-add 1 rate) num)))
  215.       (math-add (math-mul amount
  216.               (math-div (math-sub p 1)
  217.                     rate))
  218.         (math-mul (or initial 0) p))))
  219. )
  220. (put 'calcFunc-fv 'math-expandable t)
  221.  
  222. (defun calcFunc-fvl (rate num amount)
  223.   (calcFunc-fv rate num 0 amount)
  224. )
  225. (put 'calcFunc-fvl 'math-expandable t)
  226.  
  227. (defun calcFunc-fvb (rate num amount &optional initial)
  228.   (math-check-financial rate num)
  229.   (math-with-extra-prec 2
  230.     (let ((p (math-pow (math-add 1 rate) num)))
  231.       (math-add (math-mul amount
  232.               (math-div (math-mul (math-sub p 1)
  233.                           (math-add 1 rate))
  234.                     rate))
  235.         (math-mul (or initial 0) p))))
  236. )
  237. (put 'calcFunc-fvb 'math-expandable t)
  238.  
  239. (defun calcFunc-pmt (rate num amount &optional lump)
  240.   (math-check-financial rate num)
  241.   (math-with-extra-prec 2
  242.     (let ((p (math-pow (math-add 1 rate) num)))
  243.       (math-div (math-mul (math-sub amount
  244.                     (math-div (or lump 0) p))
  245.               rate)
  246.         (math-sub 1 (math-div 1 p)))))
  247. )
  248. (put 'calcFunc-pmt 'math-expandable t)
  249.  
  250. (defun calcFunc-pmtb (rate num amount &optional lump)
  251.   (math-check-financial rate num)
  252.   (math-with-extra-prec 2
  253.     (let ((p (math-pow (math-add 1 rate) num)))
  254.       (math-div (math-mul (math-sub amount (math-div (or lump 0) p)) rate)
  255.         (math-mul (math-sub 1 (math-div 1 p))
  256.               (math-add 1 rate)))))
  257. )
  258. (put 'calcFunc-pmtb 'math-expandable t)
  259.  
  260. (defun calcFunc-nper (rate pmt amount &optional lump)
  261.   (math-compute-nper rate pmt amount lump nil)
  262. )
  263. (put 'calcFunc-nper 'math-expandable t)
  264.  
  265. (defun calcFunc-nperb (rate pmt amount &optional lump)
  266.   (math-compute-nper rate pmt amount lump 'b)
  267. )
  268. (put 'calcFunc-nperb 'math-expandable t)
  269.  
  270. (defun calcFunc-nperl (rate pmt amount)
  271.   (math-compute-nper rate pmt amount nil 'l)
  272. )
  273. (put 'calcFunc-nperl 'math-expandable t)
  274.  
  275. (defun math-compute-nper (rate pmt amount lump bflag)
  276.   (and lump (math-zerop lump)
  277.        (setq lump nil))
  278.   (and lump (math-zerop pmt)
  279.        (setq amount lump
  280.          lump nil
  281.          bflag 'l))
  282.   (or (math-objectp rate) (and math-expand-formulas (null lump))
  283.       (math-reject-arg rate 'numberp))
  284.   (and (math-zerop rate)
  285.        (math-reject-arg rate 'nonzerop))
  286.   (or (math-objectp pmt) (and math-expand-formulas (null lump))
  287.       (math-reject-arg pmt 'numberp))
  288.   (or (math-objectp amount) (and math-expand-formulas (null lump))
  289.       (math-reject-arg amount 'numberp))
  290.   (if lump
  291.       (progn
  292.     (or (math-objectp lump)
  293.         (math-reject-arg lump 'numberp))
  294.     (let ((root (math-find-root (list 'calcFunc-eq
  295.                       (list (if bflag
  296.                             'calcFunc-pvb
  297.                           'calcFunc-pv)
  298.                         rate
  299.                         '(var DUMMY var-DUMMY)
  300.                         pmt
  301.                         lump)
  302.                       amount)
  303.                     '(var DUMMY var-DUMMY)
  304.                     '(intv 3 0 100)
  305.                     t)))
  306.       (if (math-vectorp root)
  307.           (nth 1 root)
  308.         root)))
  309.     (math-with-extra-prec 2
  310.       (let ((temp (if (eq bflag 'l)
  311.               (math-div amount pmt)
  312.             (math-sub 1 (math-div (math-mul amount rate)
  313.                       (if bflag
  314.                           (math-mul pmt (math-add 1 rate))
  315.                         pmt))))))
  316.     (if (or (math-posp temp) math-expand-formulas)
  317.         (math-neg (calcFunc-log temp (math-add 1 rate)))
  318.       (math-reject-arg pmt "*Payment too small to cover interest rate")))))
  319. )
  320.  
  321. (defun calcFunc-rate (num pmt amount &optional lump)
  322.   (math-compute-rate num pmt amount lump 'calcFunc-pv)
  323. )
  324.  
  325. (defun calcFunc-rateb (num pmt amount &optional lump)
  326.   (math-compute-rate num pmt amount lump 'calcFunc-pvb)
  327. )
  328.  
  329. (defun math-compute-rate (num pmt amount lump func)
  330.   (or (math-objectp num)
  331.       (math-reject-arg num 'numberp))
  332.   (or (math-objectp pmt)
  333.       (math-reject-arg pmt 'numberp))
  334.   (or (math-objectp amount)
  335.       (math-reject-arg amount 'numberp))
  336.   (or (null lump)
  337.       (math-objectp lump)
  338.       (math-reject-arg lump 'numberp))
  339.   (let ((root (math-find-root (list 'calcFunc-eq
  340.                     (list func
  341.                       '(var DUMMY var-DUMMY)
  342.                       num
  343.                       pmt
  344.                       (or lump 0))
  345.                     amount)
  346.                   '(var DUMMY var-DUMMY)
  347.                   '(intv 3 (float 1 -4) 1)
  348.                   t)))
  349.     (if (math-vectorp root)
  350.     (nth 1 root)
  351.       root))
  352. )
  353.  
  354. (defun calcFunc-ratel (num pmt amount)
  355.   (or (math-objectp num) math-expand-formulas
  356.       (math-reject-arg num 'numberp))
  357.   (or (math-objectp pmt) math-expand-formulas
  358.       (math-reject-arg pmt 'numberp))
  359.   (or (math-objectp amount) math-expand-formulas
  360.       (math-reject-arg amount 'numberp))
  361.   (math-with-extra-prec 2
  362.     (math-sub (math-pow (math-div pmt amount) (math-div 1 num)) 1))
  363. )
  364.  
  365. (defun calcFunc-irr (&rest vecs)
  366.   (math-compute-irr vecs 'calcFunc-npv)
  367. )
  368.  
  369. (defun calcFunc-irrb (&rest vecs)
  370.   (math-compute-irr vecs 'calcFunc-npvb)
  371. )
  372.  
  373. (defun math-compute-irr (vecs func)
  374.   (let* ((flat (math-flatten-many-vecs vecs))
  375.      (root (math-find-root (list func
  376.                      '(var DUMMY var-DUMMY)
  377.                      flat)
  378.                    '(var DUMMY var-DUMMY)
  379.                    '(intv 3 (float 1 -4) 1)
  380.                    t)))
  381.     (if (math-vectorp root)
  382.     (nth 1 root)
  383.       root))
  384. )
  385.  
  386. (defun math-check-financial (rate num)
  387.   (or (math-objectp rate) math-expand-formulas
  388.       (math-reject-arg rate 'numberp))
  389.   (and (math-zerop rate)
  390.        (math-reject-arg rate 'nonzerop))
  391.   (or (math-objectp num) math-expand-formulas
  392.       (math-reject-arg num 'numberp))
  393. )
  394.  
  395.  
  396. (defun calcFunc-sln (cost salvage life &optional period)
  397.   (or (math-realp cost) math-expand-formulas
  398.       (math-reject-arg cost 'realp))
  399.   (or (math-realp salvage) math-expand-formulas
  400.       (math-reject-arg salvage 'realp))
  401.   (or (math-realp life) math-expand-formulas
  402.       (math-reject-arg life 'realp))
  403.   (if (math-zerop life) (math-reject-arg life 'nonzerop))
  404.   (if (and period
  405.        (if (math-num-integerp period)
  406.            (or (Math-lessp life period) (not (math-posp period)))
  407.          (math-reject-arg period 'integerp)))
  408.       0
  409.     (math-div (math-sub cost salvage) life))
  410. )
  411. (put 'calcFunc-sln 'math-expandable t)
  412.  
  413. (defun calcFunc-syd (cost salvage life period)
  414.   (or (math-realp cost) math-expand-formulas
  415.       (math-reject-arg cost 'realp))
  416.   (or (math-realp salvage) math-expand-formulas
  417.       (math-reject-arg salvage 'realp))
  418.   (or (math-realp life) math-expand-formulas
  419.       (math-reject-arg life 'realp))
  420.   (if (math-zerop life) (math-reject-arg life 'nonzerop))
  421.   (or (math-realp period) math-expand-formulas
  422.       (math-reject-arg period 'realp))
  423.   (if (or (Math-lessp life period) (not (math-posp period)))
  424.       0
  425.     (math-div (math-mul (math-sub cost salvage)
  426.             (math-add (math-sub life period) 1))
  427.           (math-div (math-mul life (math-add life 1)) 2)))
  428. )
  429. (put 'calcFunc-syd 'math-expandable t)
  430.  
  431. (defun calcFunc-ddb (cost salvage life period)
  432.   (if (math-messy-integerp period) (setq period (math-trunc period)))
  433.   (or (integerp period) (math-reject-arg period 'fixnump))
  434.   (or (math-realp cost) (math-reject-arg cost 'realp))
  435.   (or (math-realp salvage) (math-reject-arg salvage 'realp))
  436.   (or (math-realp life) (math-reject-arg life 'realp))
  437.   (if (math-zerop life) (math-reject-arg life 'nonzerop))
  438.   (if (or (Math-lessp life period) (<= period 0))
  439.       0
  440.     (let ((book cost)
  441.       (res 0))
  442.       (while (>= (setq period (1- period)) 0)
  443.     (setq res (math-div (math-mul book 2) life)
  444.           book (math-sub book res))
  445.     (if (Math-lessp book salvage)
  446.         (setq res (math-add res (math-sub book salvage))
  447.           book salvage)))
  448.       res))
  449. )
  450.  
  451.  
  452.  
  453.